home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
Yerk 3.64
/
Float source
/
fpI⁄O
< prev
next >
Wrap
Text File
|
1993-01-27
|
14KB
|
367 lines
\ FPI/O -- floating-point I/O support for 68000 SANE engine.
\ 5/11/85 ssg Version 1.0
\ 9/26/85 cbd Modified for float heap, removed minor methods
\ 2/07/86 gdc Added words atof and f.r, changed eprint to eprint, printxyz
\ 8/16/86 cdn Eliminated finit & Stringer shorten
\ 5/26/91 rfl Eliminated Stringer class altogether.
\ 10/26/91 rfl abs in front of /mod
\ 12/17/92 rfl fixed a few problems that might occur due to not locking handles
\ 01/26/93 rfl protect parse: to reject a possible float if 2 decimal points are mistakenly
\ adjacent. The case of " 1.234.56" is interpreted as an integer
Decimal
\ Some useful constants
256 constant neg
0 constant pos
256 constant FixedDecimal
0 constant FloatDecimal
0 value topxyz \ top of string being converted to float
sCon zeros "000000000000000000000000000000000000000000000000000000000000000000000000000"
:CLASS FPI/O <Super Object
\ SANE Record Decimal ( x:= (-1)^sgn * 10^exp * SigDig )
INT sgn \ sign; 0=pos, 256=neg
INT exp \ as if decimal point were to the right of SigDig
22 BYTES SigDig \ to fake string[20] ; 22 to make even
\ SANE Record DecForm
INT style \ Float=0; Fixed=256
INT digits \ # of sig digits,if float; # dec. places,if fixed.
BasicStr outStr \ to hold formatted output string
BasicStr expStr \ to hold formatted exponent string
String floater \ to hold number for makefloat
var places \ number of places to right of dec. pt.
2 BYTES scratch
BasicStr char \ scratch character
( -- )
:M CLEAR: addr: sgn 26 erase clear: outStr clear: expstr
clear: floater clear: char ;M
( -- ) \ Initialize strings etc.
:M INIT: new: outStr new: expStr
new: floater new: char clear: self ;M
( -- )
:M EINIT: clear: self FloatDecimal put: style 19 put: digits ;M
( -- ) \ Initialize for fixed conversion
:M FINIT: clear: self FixedDecimal put: style ;M
( -- ) \ Puts a zero in decimal record
:M ZERO: clear: self $ 0130 addr: sigDig w! ;M
( -- float ) \ ==== attempt to convert decimal to a float;
:M DEC2FLOAT: { \ flt -- flt }
abs: sgn \ Addr of decimal record
new: fltMem -> flt flt 2+ +base \ Absolute Destination address
$ 0009 \ FFEXT FOD2B + -- Opcode for decimal to binary; dest=extended
fp68k flt \ Call FP68K
;M
( float -- ) \ ==== convert float to decimal ==== \
:M FLOAT2DEC: { flt -- }
abs: style \ Absolute Addr of Decform record
flt 2+ +base \ Absolute Addr of source
abs: sgn \ Absolute Addr of Decimal record
$ 000b \ FFEXT FOB2D + -- Opcode for binary to decimal; source=extended
fp68k flt fdrop \ Call FP68K, dispose of float
;M
( width -- ) \ Set up float for in decimal record in scientific format,
\ left-justified in a field of width characters.
:M PRINTXYZ: { flag1 width \ expn flag -- EXPSTR OUTSTR flag }
false -> flag
get: sgn neg = IF ascii - ELSE bl THEN
addr: sigDig count drop \ addr --
c@ CASE
ascii 0 flag1 or OF emit
" 0.E+0 " type width 7 - spaces ENDOF
ascii I OF emit " Infinity " type width 10 - spaces ENDOF
ascii N OF emit width 14 >
IF " Not a number " type width 14 - spaces
ELSE " NaN " type width 5 - spaces
THEN ENDOF
( default )
flag1 IF 26 -> width THEN
true -> flag
swap +: outstr \ prefix with sign determined in first line
ascii E +: expstr
get: exp get: digits 1- + dup abs -> expn 0<
IF ascii - ELSE ascii + THEN +: expStr \ put in sign of exponent
BEGIN
2 moveto: expStr expn abs 10 /mod -> expn
$ 30 + addr: scratch c!
addr: scratch 1 insert: expStr
expn not
UNTIL bl +: expstr
addr: sigDig count add: outStr \ Copy Sigdig to outStr
2 moveto: outStr ascii . addr: scratch c!
addr: scratch 1 insert: outStr \ Put in decimal pt.
ENDCASE
flag ;M
:M EPRINT: { width -- }
false width printxyz: self
IF ( flag from printxyz )
get: expStr dup \ addr len len --
width swap - 3 max 19 min \ addr len trlen --
get: outstr drop swap type type
THEN ;M
( -- char t OR f ) \ does basicstr next for suppressing 0's
:M NEXT0: { -- char t / f }
next: floater next: floater drop ascii . =
IF
drop drop false
ELSE
where: floater 1- moveto: floater
THEN ;M
\ Converts an e. type float into a normal float
\ without an E.
:M MAKEFLOAT: { width decimal \ dot exp -- floater }
size: expstr 1- setSize: expstr
2 moveto: expstr 0 next: expstr
BEGIN
WHILE
ascii 0 - + 10 * next: expstr \ find size of exponent
REPEAT
10 / -> exp
zeros put: floater \ create initial floater
lock: outStr get: outstr 1- swap 1+ swap add: floater unlock: outStr
zeros add: floater 0 moveto: floater
ascii . charof: floater drop -> dot \ find location of dot
" ." delete: floater \ drop dot
1 moveto: expstr next: expstr drop ascii - = \ find sign of exponent
IF
dot exp - \ - exponent
ELSE
dot exp + \ + exponent
THEN
dup -> dot moveto: floater " ." insert: floater \ put new dot place
dot decimal + get: floater drop + dup put: places
BEGIN \ round off decimals
c@ ascii 4 > \ if last digit is less then 5 then truncate
IF
get: places c@ ascii 9 > \ if carry then set digit to 0
IF
ascii 0 clear: char +: char
get: places get: floater drop - moveto: floater
1 substr: floater get: char replace: floater
THEN
get: places 1- dup dot get: floater drop + = \ check for dot
IF 1- THEN dup put: places
c@ 1+ clear: char +: char \ add one to digit
get: places get: floater drop - moveto: floater \ insert digit
1 substr: floater get: char replace: floater
get: places c@ ascii 9 > \ if there is a carry
IF \ do next left digit
true
ELSE
false
THEN
ELSE
false
THEN
WHILE
get: places
REPEAT
get: floater drop dot decimal + \ drop excess right digits
put: floater
32 +: floater \ add space at end
size: floater width - 0 0 moveto: floater \ drop excess left digits
BEGIN
2dup <>
WHILE
next: floater drop ascii 0 =
IF
1+
ELSE
swap drop dup
THEN
REPEAT swap drop
size: floater over - over moveto: floater
substr: floater put: floater drop
0 moveto: floater 0 next0: self \ suppress leading 0's
BEGIN
WHILE
ascii 0 =
IF
1+ next0: self
ELSE
false
THEN
REPEAT
dup size: floater over - swap moveto: floater substr: floater
put: floater
0 moveto: floater \ add sign at front
get: sgn neg =
IF
" -"
ELSE
" "
THEN
insert: floater
0 moveto: floater 0 \ add spaces for suppressed 0's
DO
" " insert: floater
LOOP ;M
\ Carry out f.r
:M FLOATOUT: { width decimal -- }
129 width printxyz: self
IF ( flag from printxyz )
width 1- decimal 1+ makefloat: self
print: floater
THEN ;M
( addr -- beg end dot ee t ) \ If float found; ie, decimal pt. found
( addr -- f ) \ If no decimal pt. found
:M PARSE: { addr \ beg end dot ee numdec -- beg end dot ee t | f }
\ ==== Parse for decimal pt. ==== \
false addr count over + dup -> topxyz swap
0 -> numDec
DO ic@ ascii . =
IF i -> dot i 1+ c@ ascii . <>
IF drop true THEN
leave
THEN
LOOP \ bool --
IF 1 ++> addr \ Process sign
pos put: sgn
addr c@ dup ascii - =
IF 1 ++> addr neg put: sgn THEN
ascii + =
IF 1 ++> addr THEN
\ ==== Skip 0's and '.'; ==== \
BEGIN addr c@ dup ascii 0 = swap ascii . = or
WHILE 1 ++> addr
REPEAT
addr -> beg \ addr of putative leading sig digit
\ ==== Test for zero ==== \
topxyz beg <=
beg c@ dup dup ascii e = swap ascii E = rot bl = or or or
IF -2 -> ee true \ signal that float is zero
ELSE \ ==== Parse for 'E' or end of string ==== \
false -> ee ee not \ Use ee as a flag now
BEGIN
addr topxyz - land
WHILE
1 ++> addr
addr c@
CASE \ Test for blank or e; true -> ee if found
bl OF -1 -> ee ENDOF
ascii e OF addr -> ee ENDOF
ascii E OF addr -> ee ENDOF
ENDCASE
ee not \ Loop flag
REPEAT
\ ==== Parse from end of string for last sig digit ==== \
BEGIN -1 ++> addr
addr c@ dup ascii 0 = swap ascii . = or
WHILE
REPEAT
addr -> end
\ ===== Test for valid chars ===== \
true \ Innocent till proven guilty
end 1+ beg
DO ic@ 10 digit \ Are chars honest decimal digits?
IF drop
ELSE i dot <> \ Was it other than a decimal point?
IF drop false leave THEN
THEN
LOOP
THEN
IF beg end dot ee true ELSE false THEN
ELSE false
THEN ;M
( addr -- flt t OR f ) \ Converts string to float
\ Returns true if float converted successfully
:M ATOF: { addr \ beg end dot ee esign -- flt t OR f }
clear: self
addr count swap drop 21 < \ Disqualify if longer than 20 chars
IF addr parse: self
IF -> ee -> dot -> end -> beg
\ ==== Process exponent ==== \
1 -> esign \ Innocent until proven guilty
ee -2 = \ Zero?
IF zero: self \ put a zero in decimal record
ELSE ee -1 <> \ If scientific notation used
IF 1 ++> ee \ Advance past 'E'
ee c@ dup
ascii - =
IF 1 ++> ee -1 -> esign THEN
ascii + =
IF 1 ++> ee THEN
ee -> addr \ ee to contain exponent now
0 -> ee
BEGIN
addr topxyz -
IF
addr c@ 10 digit
ELSE
false
THEN
WHILE
ee 10 * + -> ee 1 ++> addr
REPEAT
ELSE 0 -> ee
THEN
ee esign * dot end - dup 0> IF 2- ELSE 1- THEN + -> ee
ee put: exp
\ ==== copy digit string to SigDig ==== \
1 -> ee \ Use ee as counter
end 1+ beg
DO i dot <> \ Copy unless decimal point
IF ic@ addr: sigDig ee + c! 1 ++> ee THEN
LOOP
ee addr: sigDig c! \ Store count byte
THEN
dec2float: self \ attempt conversion to float
fdup
float2dec: self \ reconvert to confirm
addr: sigDig 1+ c@ dup dup
ascii I = swap ascii N = rot ascii ? = or or
IF fdrop false \ conversion unsuccessful
ELSE true \ Success!
THEN
ELSE false
THEN
ELSE false
THEN ;M
;Class
fpi/o floati/o \ The default fpi/o object
init: floati/o
( width -- )
( flt -- ) \ Print a float in scientific format in a field of width chars.
: e.r { flt width -- }
einit: floati/o flt float2dec: floati/o
width eprint: floati/o ;
( flt -- ) \ Print a float in scientific format.
: e. 26 e.r ;
( addr len -- fval T ) \ Successful \ Converts a relative str255 string
( addr len -- F ) \ Unsuccessful \ into a floating point number.
: atof { addr len -- fval T / F }
addr len str255 -base atof: floati/o ;
( flt width decimal -- ) \ Print a float without exponents, in a field of
\ width wide and of decimal places
: f.r { flt width decimal -- }
einit: floati/o flt float2dec: floati/o
width decimal floatout: floati/o ;